home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1996 / MacHack 1996.toast / Hacks / Hacks ’87 / Source ƒ.sit / Source ƒ / lisp source / Chapter18.sch next >
Encoding:
Text File  |  1986-08-10  |  6.9 KB  |  191 lines  |  [TEXT/EDIT]
  1. ;;  Here's the MacScheme version of the forward chaining rule based
  2. ;;  search example from _LISP second edition_, by Winston and Horn
  3. ;;  Addison-Wesley, publishers
  4. ;;      Greg Grubbs, Aug. '86      GEnie: G.GRUBBS
  5.  
  6. ;; first, load in MATCH, the pattern matching function from chapter 17
  7. (load "match.sch")
  8. ;;  ASSERTIONS is a globally accessible variable which contains our knowledge
  9. ;;  base; inferred conclusions will be added here.
  10. (set! assertions
  11.    '((bozo is a cheetah)
  12.      (bozo is a parent of sugar)
  13.      (bozo is a parent of billy)
  14.      (sweekums is a penguin)
  15.      (king is a penguin)
  16.      (king is a parent of rex)))
  17.  
  18. ; add aught to our assertion list
  19. (define  (remember new)
  20.     (cond ((member new assertions) nil)
  21.           (else (set! assertions (cons new assertions))
  22.               new)))
  23.  
  24. ;; 'recall' comes from problem 18-1
  25. ;;  it finds all assertions which match a given pattern
  26. ;;  try:  (recall '(> animal) is a (> type))
  27. (define (recall pattern)
  28.     (recall1 pattern assertions))
  29. (define (recall1 pattern assertions)
  30.     (cond ((null? assertions) nil)
  31.           ((match pattern (car assertions) nil)
  32.    (cons (car assertions)
  33.          (recall1 pattern (cdr assertions))))
  34.   (else (recall1 pattern (cdr assertions)))))
  35.   
  36. ;;  limited stream handling routines
  37. (define (combine-streams s1 s2) (append s1 s2))
  38. (define (add-to-stream e s) (cons e s))
  39. (define (first-of-stream s) (car s))
  40. (define (rest-of-stream s) (cdr s))
  41. (define (empty-stream? s) (null? s))
  42. (define (make-empty-stream) nil)
  43.  
  44. ;;  
  45. (define (filter-assertions pattern initial-a-list)
  46.     (do ((assertions assertions (cdr assertions))
  47.          (a-list-stream (make-empty-stream)))
  48.         ((null? assertions) a-list-stream)
  49.       (let ((new-a-list (match pattern (car assertions) initial-a-list)))
  50.         (cond (new-a-list (set! a-list-stream
  51.                       (add-to-stream new-a-list a-list-stream)))))))
  52.  
  53.  
  54. (define (filter-a-list-stream pattern a-list-stream)
  55.     (cond ((empty-stream? a-list-stream) (make-empty-stream))
  56.           (else (combine-streams
  57.       (filter-assertions pattern (first-of-stream a-list-stream))
  58.       (filter-a-list-stream pattern (rest-of-stream a-list-stream))))))
  59.  
  60. (define (cascade-through-patterns patterns a-list-stream)
  61.     (cond ((null? patterns) a-list-stream)
  62.           (else (filter-a-list-stream (car patterns)
  63.                            (cascade-through-patterns (cdr patterns)
  64.                               a-list-stream)))))
  65.  
  66.  
  67. ;;  Dig the nested LETs here; The original procedure uses LET*, which is not
  68. ;;  defined in MacScheme, though other Scheme implementations have it.
  69. (define (use-rule rule)
  70.       (let ((rule-name (cadr rule))
  71.             (ifs (reverse (cdr (caddr rule))))
  72.             (thens (cdr (cadddr rule))))
  73.         (let
  74.           ((a-list-stream (cascade-through-patterns
  75.                            ifs
  76.                            (add-to-stream '() (make-empty-stream)))))
  77.           (let
  78.             ((action-stream (feed-to-actions 
  79.                              rule-name thens a-list-stream)))
  80.             (not (empty-stream? action-stream))))))
  81. (define (spread-through-actions rule-name actions a-list)
  82.     (do ((actions actions (cdr actions))
  83.          (action-stream (make-empty-stream)))
  84.         ((null? actions) action-stream)
  85.         (let ((action (replace-variables (car actions) a-list)))
  86.           (cond ((remember action)
  87.                  (print `(rule ,rule-name says ,@action))
  88.                  (set! action-stream (add-to-stream action action-stream)))))))
  89. (define (print x) (begin (display x) (newline))) ; make it pretty
  90.  
  91. (define (replace-variables s a-list)
  92.   (cond ((atom? s) s)
  93.         ((equal? (car s) '<)
  94.          (cadr (assoc (pattern-variable s) a-list)))
  95.         (else (cons (replace-variables (car s) a-list)
  96.                     (replace-variables (cdr s) a-list)))))
  97. (define (feed-to-actions rule-name actions a-list-stream)
  98.   (cond ((empty-stream? a-list-stream) (make-empty-stream))
  99.         (else (combine-streams
  100.                (spread-through-actions rule-name
  101.                                        actions
  102.                                        (first-of-stream a-list-stream))
  103.                (feed-to-actions rule-name
  104.                                 actions
  105.                                 (rest-of-stream a-list-stream))))))
  106. (define (forward-chain)
  107.   (do ((rules-to-try rules (cdr rules-to-try))
  108.        (progress-made '()))
  109.       ((null? rules-to-try) progress-made)
  110.      (cond ((use-rule (car rules-to-try))
  111.             (set! rules-to-try rules)
  112.             (set! progress-made #!true)))))
  113.  
  114. ;; here's some o' dem silly rules
  115. (set! rules
  116. '((rule identify1
  117.       (if ((> animal) has hair))
  118.       (then ((< animal) is mammal)))
  119. (rule identify2
  120.       (if ((> animal) gives milk))
  121.       (then ((< animal) is mammal)))
  122. (rule identify3
  123.       (if ((> animal) has feathers))
  124.       (then ((< animal) is bird)))
  125. (rule identify4
  126.       (if ((> animal) flies)
  127.           ((< animal) lays eggs))
  128.       (then ((< animal) is bird)))
  129. (rule identify5
  130.       (if ((> animal) eats meat))
  131.       (then ((< animal) is carnivore)))
  132. (rule identify6
  133.       (if ((> animal) has pointed teeth)
  134.           ((< animal) has claws)
  135.           ((< animal) has forward eyes))
  136.       (then ((< animal) is carnivore)))
  137. (rule identify7
  138.       (if ((> animal) is mammal)
  139.           ((< animal) has hoofs))
  140.       (then ((< animal) is ungulate)))
  141. (rule identify8
  142.       (if ((> animal) is mammal)
  143.           ((< animal) chews cud))
  144.       (then ((< animal) is ungulate)
  145.             ((< animal) is even toed)
  146.             ((< animal) is probably a big ugly cow)))
  147. (rule identify9
  148.       (if ((> animal) is mammal)
  149.           ((< animal) is carnivore)
  150.           ((< animal) has tawny color)
  151.           ((< animal) has dark spots))
  152.       (then ((< animal) is cheetah)))
  153. (rule identify10
  154.       (if ((> animal) is mammal)
  155.           ((< animal) is carnivore)
  156.           ((< animal) has tawny color)
  157.           ((< animal) has black stripes))
  158.       (then ((< animal) is tiger)))
  159. (rule identify11
  160.       (if ((> animal) is ungulate)
  161.           ((< animal) has long neck)
  162.           ((< animal) has long legs)
  163.           ((< animal) has dark spots))
  164.       (then ((< animal) is giraffe)))
  165. (rule identify12
  166.       (if ((> animal) is ungulate)
  167.           ((< animal) has black stripes))
  168.       (then ((< animal) is zebra)))
  169. (rule identify13
  170.       (if ((> animal) is bird)
  171.           ((< animal) does not fly)
  172.           ((< animal) has long neck)
  173.           ((< animal) has long legs)
  174.           ((< animal) is black and white))
  175.       (then ((< animal) is ostrich)))
  176. (rule identify14
  177.       (if ((> animal) is bird)
  178.           ((< animal) does not fly)
  179.           ((< animal) swims)
  180.           ((< animal) is black and white))
  181.       (then ((< animal) is penguin)
  182.             ((< animal) might even be ole herring breath himself)))
  183. (rule identify15
  184.       (if ((> animal) is bird)
  185.           ((< animal) flies well))
  186.       (then ((< animal) is albatross)))
  187. (rule identify16
  188.       (if ((> animal) is a (> type))
  189.           ((< animal) is a parent of (> child)))
  190.       (then ((< child) is a (< type))))))
  191.